Hyper Stacks 1994 May/Hyper Stacks (Pacific HiTech)(1994)[Mac].iso/HyperTalk/Serial Port Toolkit v.2.5/Source Code/XModem.p

Text File | 1988-04-18 | 12.8 KB | 521 lines | [TEXT/MPS ]

(*
    XModem command,folderName,fileName -- Send or receive a file using the XModem protocol. If
        command is "receive", then receive a file and name it as specified. If the command is "send",
        then send the named file. The folder and file name are separate so that the file can be downloaded
        into the right folder before knowing the proper name. Assume the serial port has already been opened.

    This XModem implementation handles normal XModem and CRC XModem. It does not know anything
    about the format of the data being sent or received -- i.e., it doesn't know anything about MacBinary.

    It sends very fast. Receive could be sped up some (it should compute the CRC as it's receiving, not
    afterward), but it isn't all that bad either.

    To compile and link this file using Macintosh Programmer's Workshop,

        pascal -w XModem.p
        link -m ENTRYPOINT -o HyperCommands -rt XCMD=7036 -sn Main=XModem ∂
            XModem.p.o "{MPW}"Libraries:interface.o "{MPW}"PLibraries:PasLib.o

    © Copyright 1987,88 by Apple Computer, Inc.

    Initial coding 9/87 by Harry R. Chesley.
*)

{$R-}

{$S XModem }     { Segment name must be the same as the command name. }

unit DummyUnit;

interface

uses MemTypes, QuickDraw, OSIntf, ToolIntf, HyperXCmd;

procedure EntryPoint(paramPtr: XCmdPtr);

implementation

type

Str31 = String[31];

procedure XModem(paramPtr: XCmdPtr); forward;

procedure EntryPoint(paramPtr: XCmdPtr);

    begin
        XModem(paramPtr);
    end;

{«XModem(paramPtr: XCmdPtr)»}

procedure XModem(paramPtr: XCmdPtr);

    const TEMPFILENAME = '*** recvXModemTemp ***';
        RETRY = 5;
        RECSIZE = 128;
        EOT = 4;
        CRC = ord('C');
        ACK = 6;
        NAK = $15;
        CAN = $18;
        SOH = 1;

    var theFolder: str255;
        theFile: Str255;
        tempFile: str255;
        cmd: Str255;                                                { The command. }
        dummy: OSErr;
        fileRef: integer;                                            { Input or output file reference number. }
        useCRC: boolean;                                            { True if we're using CRCs. }
        crcAccum, checkSum: longInt;                        { The CRC or checksum. }
        buffer: array [1..RECSIZE] of SignedByte;        { The I/O buffer. }
        recNum: longInt;                                            { The current record number. }

    {$I XCmdGlue.inc}

    procedure Fail(errMsg: Str255);
        { Set theResult and quit. }
        begin
            paramPtr^.returnValue := PasToZero(errMsg);
            exit(XModem);
        end;

    {$I SPortUtil.inc}

{«Miscellaneous Routines»    Miscellaneous Routines }

    function byteAvailable: boolean;
        { Returns true if a serial port input byte is available. }

        var l: longInt;

        begin
            if SerGetBuf(ThisSPort.portInDev,l) <> noErr then Fail('SerGetBuf failed');
            byteAvailable :=  l > 0;
        end;

    function readOne: SignedByte;
        { Reads a byte from the serial port. }

        var l: longInt;
            theByte: SignedByte;

        begin
            l := 1;
            if FSRead(ThisSPort.portInDev,l,@theByte) <> noErr then Fail('FSRead failed');
            readOne := theByte;
        end;

    procedure tx(b: SignedByte);
        { Transmits a byte to to serial port. }

        var theByte: SignedByte;
            l: longInt;

        begin
            theByte := b;
            l := 1;
            if FSWrite(ThisSPort.portOutDev,l,@theByte) <> noErr then Fail('FSWrite failed');
        end;

    function swait: SignedByte;
        { Waits up to 2 seconds for a byte from the serial port. }

        var stoppingTime: longInt;
            theByte: SignedByte;
            l: longInt;

        begin
            stoppingTime := TickCount + 120;
            while TickCount < stoppingTime do
                if byteAvailable then
                    begin
                        swait := readOne;
                        exit(swait);
                    end;
            swait := 0;
        end;

    procedure clearInput;
        { Clear out any residual characters on the input port. }

        var theByte: SignedByte;

        begin
            while byteAvailable do theByte := readOne;
        end;

    procedure sleep(ticks: longInt);
        { Wait for ticks 1/60ths of a second. }

        var finalTime: longInt;

        begin
            finalTime := TickCount + ticks;
            repeat until TickCount >= finalTime;
        end;

{«CRC/Checksum Routines»    CRC/Checksum Routines }

    procedure clrCrc;
        { Clear out the CRC/checksum. }

        begin
            crcAccum := 0;
            checkSum := 0;
        end;

    procedure updCrc(b: SignedByte);
        { Process one more byte into the CRC/Checksum. }

        var i: integer;
            flag: longInt;

        begin
            if useCRC then
                begin
                    for i := 7 downto 0 do
                        begin
                            flag := BitAnd(crcAccum,$08000);
                            crcAccum := BitShift(crcAccum,1);
                            if BitAnd(BitShift(1,i),b) <> 0 then crcAccum := BitOr(crcAccum,1);
                            if flag <> 0 then crcAccum := BitXor(crcAccum,$01021);
                        end;
                end
            else checkSum := checkSum + BitAnd(b,$FF);
        end;

{«sendFile»}

    procedure sendFile;
        { Open and send a file. }

        var didSend: boolean;        { True if send was successfull. }

        function send: boolean;
            { Send the file (once it's been opened). }

            var i: integer;

            procedure Fail(errMsg: Str255);
                { Set theResult and quit. }

                var dummy: OSErr;

                begin
                    dummy := FSClose(fileRef);
                    paramPtr^.returnValue := PasToZero(errMsg);
                    exit(XModem);
                end;

            function waitCan(t: longInt): SignedByte;
                { Wait up to t ticks for a byte from the serial port. }

                var stopTime: longInt;
                    theByte: SignedByte;

                begin
                    stopTime := TickCount+t;
                    while TickCount < stopTime do
                        if byteAvailable then
                            begin
                                theByte := readOne;
                                if theByte = CAN then exit(send);
                                waitCan := theByte;
                                exit(waitCan);
                            end;
                    waitCan := 0;
                end;

            procedure synch;
                { Synchronize our ACKs/NAKs and figure out if we're doing CRCs or checksums. }

                var i: integer;
                    theByte: SignedByte;

                begin
                    clearInput;
                    { Try up to ten times to synchronize. }
                    for i := 1 to 10 do
                        begin
                            { Get a character. }
                            theByte := waitCan(600);
                            { Check for NAK — normal, checksum XModem. }
                            if theByte = NAK then
                                begin
                                    useCRC := false;
                                    exit(synch);
                                end;
                            { Check for CRC — CRC style XModem. }
                            if theByte = CRC then
                                begin
                                    useCRC := true;
                                    exit(synch);
                                end;
                        end;
                    { Didn't find it. Give up. }
                    Fail('could not synchronize');
                end;

            function fillBuf: boolean;
                { Get a bufferfull from disk. }

                var l: longInt;

                begin
                    l := RECSIZE;
                    if (FSRead(fileRef,l,@buffer) <> noErr) or (l = 0) then fillBuf := false
                    else fillBuf := true;
                end;

            procedure txRec;
                { Transmit one record. }

                var i, j: integer;
                    theByte: SignedByte;

                begin
                    clearInput;
                    { Try to send the record up to 25 times. }
                    for i := 1 to 25 do
                        begin
                            { Send the record header. }
                            tx(SOH);
                            tx(BitAnd(recNum,$FF));
                            tx(BitAnd(BitXor(recNum,$FF),$FF));
                            { Send the record body, figuring the CRC as we go. }
                            clrCrc;
                            for j := 1 to RECSIZE do
                                begin
                                    tx(buffer[j]);
                                    updCrc(buffer[j]);
                                end;
                            updCrc(0); updCrc(0);
                            { Send the CRC. }
                            if useCrc then
                                begin
                                    tx(BitAnd(BitShift(crcAccum,-8),$FF));
                                    tx(BitAnd(crcAccum,$FF));
                                end
                            else tx(BitAnd(checkSum,$FF));
                            { Wait for the ACK. }
                            if waitCan(600) = ACK then
                                begin
                                    { If we succeeded, increment the record number. }
                                    recNum := recNum+1;
                                    exit(txRec);
                                end;
                        end;
                        Fail('retries exceeded')
                end;

            begin
                { Initialize and synchronize with the other side. }
                send := false;
                recNum := 1;
                synch;
                { Send the file, one record at a time. }
                while fillBuf do txRec;
                { Make sure he knows we're all done. }
                for i := 1 to 100 do
                    begin
                        tx(EOT);
                        if waitCan(60) = ACK then leave;
                    end;
                send := true;
            end;

        begin
            { Open the file to be sent. }
            if FSOpen(theFile,0,fileRef) <> noErr then Fail('no such file');

            { Send the file. }
            didSend := send;

            { Close the file. }
            if FSClose(fileRef) <> noErr then Fail('FSClose failed');
            if not didSend then Fail('send aborted');
        end;

{«receiveFile»}

    procedure receiveFile;
        { Create and receive one file. }

        var didReceive: boolean;        { True if the receive was successfull. }
                i: integer;
                lastColon: integer;
                volName: str255;

        function receive: boolean;
            { Receive the file (once it has been created on disk). }

            var i: integer;
                theByte: SignedByte;
                response: SignedByte;
                r1, r2: longInt;
                crcHi, crcLo: longInt;
                l: longInt;

            procedure Fail(errMsg: Str255);
                { Set theResult and quit. }

                var dummy: OSErr;

                begin
                    dummy := FSClose(fileRef);
                    paramPtr^.returnValue := PasToZero(errMsg);
                    exit(XModem);
                end;

            begin
                { Assume we'll fail: }
                receive := false;

                { Dump any previous residue: }
                clearInput;

                { Assume we're doing CRC XModem: }
                response := CRC;
                useCRC := true;

                { Start at record one: }
                recNum := 1;

                { Read in the file: }
                while true do
                    begin
                        { Synch up: }
                        clearInput;
                        for i := 1 to 10*RETRY do
                            begin
                                { Let him know what happened last time (or NAK him the first time). }
                                tx(response);
                                { Get a byte. }
                                theByte := swait;
                                { Check or start-of-record. }
                                if theByte = SOH then leave;
                                { Check for end-of-file. }
                                if theByte = EOT then
                                    begin
                                        tx(ACK);
                                        receive := true;
                                        exit(receive);
                                    end;
                                { Check for manual cancel. }
                                if theByte = CAN then exit(receive);
                                { If we've tried CRCs for a while, try checksums now. }
                                if i = 5*RETRY then
                                    begin
                                        if response = CRC then
                                            begin
                                                response := NAK;
                                                useCRC := false;
                                            end
                                        else leave;
                                    end;
                            end;
                        { If this isn't another block, it must be that we've run out of retries. }
                        if theByte <> SOH then exit(receive);
                        { Receive the record number (and its complement). }
                        r1 := BitAnd(swait,$FF); r2 := BitAnd(swait,$FF);
                        { Receive the record. }
                        for i := 1 to RECSIZE do buffer[i] := swait;
                        { Receive the CRC/checksum. }
                        if useCRC then crcHi := BitAnd(swait,$FF);
                        crcLo := BitAnd(swait,$FF);
                        { Assume this one'll be bad. }
                        response := NAK;
                        { Check for bad record number. }
                        if BitAnd(BitNot(r1),$FF) <> r2 then cycle;
                        { Check for bad CRC/checksum. }
                        clrCrc;
                        for i := 1 to RECSIZE do updCrc(buffer[i]);
                        updCrc(0); updCrc(0);
                        if useCRC then
                            begin
                                if (crcLo + BitShift(crcHi,8)) <> BitAnd(crcAccum,$0FFFF) then
                                    begin
                                        { Give things time to settle out. }
                                        sleep(120);
                                        cycle;
                                    end;
                            end
                        else if crcLo <> BitAnd(checkSum,$FF) then
                            begin
                                { Give things time to settle out. }
                                sleep(120);
                                cycle;
                            end;
                        { Check if this is a record we've already received. }
                        if r1 = BitAnd(recNum-1,$FF) then
                            begin
                                { If it is... }
                                response := ACK;
                                cycle;
                            end;
                        { Check if this record is WAY out of sequence. }
                        if r1 <> BitAnd(recNum,$FF) then Fail('fatal record sequencing error');
                        { Increment our expected record number. }
                        recNum := recNum+1;
                        { Write the record to disk. }
                        l := RECSIZE;
                        if FSWrite(fileRef,l,@buffer) <> noErr then Fail('FSWrite failed');
                        response := ACK;
                    end;
            end;

        begin
            { Create the temporary input file (will be renamed later to the real name if we make it OK). }
            dummy := FSDelete(tempFile,0);
            if Create(tempFile,0,'????','????') <> noErr then Fail('could not create temp file');
            if FSOpen(tempFile,0,fileRef) <> noErr then Fail('FSOpen failed on temp file');

            { Receive the file: }
            didReceive := receive;

            { Close the file, and rename the temporary file to the permanent name. }
            if FSClose(fileRef) <> noErr then Fail('FSClose failed');
            if didReceive then
                begin
                    dummy := FSDelete(theFile,0);
                    if Rename(tempFile,0,theFile) <> noErr then Fail('Rename failed');
                end
            else
                begin
                    if FSDelete(tempFile,0) <> noErr then Fail('FSDelete failed');
                    Fail('receive aborted');
                end;
            lastColon := 0;
            for i := 1 to length(theFile) do
                if theFile[i] = ':' then lastColon := i;
            if lastColon = 0 then volName := ''
            else volName := Copy(theFile,1,lastColon);
            if FlushVol(@volName,0) <> noErr then Fail('FlushVol failed');
        end;

{«Main Program»    Main Program }

    begin
        { Check the parameter count. }
        if paramPtr^.paramCount <> 3 then Fail('parameter count is not 3');

        { Get the parameters. }
        GetStrParm(1,cmd);                { First parameter is the command. }
        GetStrParm(2,theFolder);        { Second parameter is the folder to put the file in. }
        tempFile := Concat(theFolder,TEMPFILENAME);
        GetStrParm(3,theFile);            { Third parameter is file name to send/receive. }
        theFile := Concat(theFolder,theFile);

        SetUpSPortGlobals;
        EnsureOpenPort;

        { Find out what command we're doing and do it. }
        if StringEqual(cmd,'send') then sendFile
        else if StringEqual(cmd,'receive') then receiveFile
        else Fail('invalid command');
    end;

end.